unit uFtpServer;

interface

uses
  Classes, SysUtils, IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer, IdFTPList;

type
  TFtpServerThread = class(TThread)
  private
    FEvent: THandle;
    FHomeDir: string;
    FCmdLines: TThreadList;
    FIdFTPServer: TIdFTPServer;
    function CreateFptServer: TIdFTPServer;
    procedure IdFTPServerUserLogin(ASender: TIdFTPServerThread;
      const AUsername, APassword: String; var AAuthenticated: Boolean);
    procedure IdFTPServerListDirectory(ASender: TIdFTPServerThread;
      const APath: String; ADirectoryListing: TIdFTPListItems);
    procedure IdFTPServerException(AThread: TIdPeerThread;
      AException: Exception);
    procedure IdFTPServerChangeDirectory(ASender: TIdFTPServerThread;
      var VDirectory: String);
    procedure IdFTPServerRetrieveFile(ASender: TIdFTPServerThread;
      const AFileName: String; var VStream: TStream);
    procedure IdFTPServerDeleteFile(ASender: TIdFTPServerThread;
      const APathName: String);
    procedure IdFTPServerRenameFile(ASender: TIdFTPServerThread;
      const ARenameFromFile, ARenameToFile: String);
    procedure IdFTPServerStoreFile(ASender: TIdFTPServerThread;
      const AFileName: String; AAppend: Boolean; var VStream: TStream);
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddCmd(const Cmd: string);
  end;

var
  G_FtpServer: TFtpServerThread;
  
implementation

uses
  Windows, uGlobal;

type
  TFtpCmd = record
    CmdStr: string[252];
  end;
  PFtpCmd = ^TFtpCmd;
  
{ TFtpServerThread }

constructor TFtpServerThread.Create;
begin
  FEvent := CreateEvent(nil, True, False, nil);
  FCmdLines := TThreadList.Create;  
  FIdFTPServer := CreateFptServer;
  inherited Create(False);
end;

destructor TFtpServerThread.Destroy;
begin
  if Assigned(FIdFTPServer) then
    FreeAndNil(FIdFTPServer);
  with FCmdLines.LockList do
  try
    while Count>0 do
    begin
      Dispose(Items[0]);
      Delete(0);
    end;
  finally
    FCmdLines.UnlockList;
  end;
  FCmdLines.Free;
  CloseHandle(FEvent);  
  inherited;
end;

procedure TFtpServerThread.AddCmd(const Cmd: string);
var
  p: PFtpCmd;
begin
  new(p);
  FillChar(p^, Sizeof(TFtpCmd), 0);
  p.CmdStr := cmd;
  with FCmdLines.LockList do
  try
    Add(p);
  finally
    FCmdLines.UnlockList;
  end;
end;

procedure TFtpServerThread.Execute;
var
  p: PFtpCmd;
  tmpStr: string;
  cmdId: string;
  keyValue: TKeyValue;
  procedure OpenFtp;
  begin
    if FIdFTPServer.Active then
      FIdFTPServer.Active := False;
    FIdFTPServer.DefaultPort := keyValue.IValue('port', 21);
    FIdFTPServer.DefaultDataPort := keyValue.IValue('dataport', 20);
    FIdFTPServer.Bindings.Clear;
    with FIdFTPServer.Bindings.Add do
    begin
      IP := '0.0.0.0';
      Port := FIdFTPServer.DefaultPort;
    end;
    with FIdFTPServer.Bindings.Add do
    begin
      IP := '0.0.0.0';
      Port := FIdFTPServer.DefaultDataPort;
    end;    
    FHomeDir := Trim(keyValue.SValue('homedir'));
    FHomeDir := StringReplace(FHomeDir, '\', '/', [rfReplaceAll]);
    if (Length(FHomeDir)>0) and (FHomeDir[Length(FHomeDir)]='\') then
      FHomeDir[Length(FHomeDir)] := '/'
    else
      FHomeDir := FHomeDir + '/';
    FIdFTPServer.Active := True;
  end;
  procedure CloseFtp;
  begin
    FIdFTPServer.Active := False;
  end;
  procedure ResetFtp;
  begin
    if Assigned(FIdFTPServer) then
      FreeAndNil(FIdFTPServer);
    FIdFTPServer := CreateFptServer;
  end;
begin
  while not Terminated do
  begin
    with FCmdLines.LockList do
    try
      if Count>0 then
      begin
        p := Items[0];
        Delete(0);
      end else
        p := nil;
    finally
      FCmdLines.UnlockList;
    end;

    if Assigned(p) then
    begin
      tmpStr := p.CmdStr;
      Dispose(p);
      if Pos(' ', tmpStr)>0 then
      begin
        cmdId := Trim(Copy(tmpStr, 1, Pos(' ', tmpStr)-1));
        Delete(tmpStr, 1, Pos(' ', tmpStr)-1);
        tmpStr := Trim(tmpStr);
      end else
      begin
        cmdId := Trim(tmpStr);
        tmpStr := '';
      end;

      keyValue := TKeyValue.Create(';', tmpStr);
      try
        try
          if SameText(Trim(CMD_FTP_OPEN), cmdId) then
            OpenFtp
          else if SameText(Trim(CMD_FTP_CLOSE), cmdId) then
            CloseFtp
           else if SameText(Trim(CMD_FTP_RESET), cmdId) then
            ResetFtp
        except
          on E: Exception do
          begin
            PushGlobalMsg(Format('Exception cmd=%s msg=%s', [cmdId, E.Message]));
          end;
        end;
      finally
        keyValue.Free;
      end;
    end;
    WaitforSingleObject(FEvent, 500);
  end;
end;

function TFtpServerThread.CreateFptServer: TIdFTPServer;
begin
  Result := TIdFTPServer.Create(nil);
  with Result do
  begin
    OnUserLogin := IdFTPServerUserLogin;
    OnListDirectory := IdFTPServerListDirectory;
    OnException := IdFTPServerException;
    OnChangeDirectory := IdFTPServerChangeDirectory;
    OnRetrieveFile := IdFTPServerRetrieveFile;
    OnDeleteFile := IdFTPServerDeleteFile;
    OnRenameFile := IdFTPServerRenameFile;
    OnStoreFile := IdFTPServerStoreFile;
    DefaultPort := 21;
    AnonymousAccounts.Add('anonymous');
    AnonymousAccounts.Add('ftp');
    AnonymousAccounts.Add('guest');
    EmulateSystem := ftpsUNIX;
    SystemType := 'WIN32';
  end;
end;

procedure TFtpServerThread.IdFTPServerException(AThread: TIdPeerThread;
  AException: Exception);
begin
  OutputDebugString('IdFTPServerException');
  PushGlobalMsg(Format('Exception IdFTPServerException msg=%s', [AException.Message]));
end;

procedure TFtpServerThread.IdFTPServerChangeDirectory(
  ASender: TIdFTPServerThread; var VDirectory: String);
begin
  ;
end;

procedure TFtpServerThread.IdFTPServerDeleteFile(
  ASender: TIdFTPServerThread; const APathName: String);
begin
  DeleteFile(PChar(Utf8ToAnsi(ASender.HomeDir + APathName)));
end;

procedure TFtpServerThread.IdFTPServerListDirectory(
  ASender: TIdFTPServerThread; const APath: String;
  ADirectoryListing: TIdFTPListItems);
var
  Path: string;
  f: SysUtils.TSearchRec;
begin
  ADirectoryListing.DirectoryName := APath;
  Path := ASender.HomeDir + Utf8ToAnsi(APath);
  if DirectoryExists(Path) then
  begin
    if SysUtils.FindFirst(Path + '*.*', faAnyFile, f )=0 then
    begin
      repeat
        with ADirectoryListing.Add do
        begin
          if f.Attr and faDirectory = faDirectory then
            ItemType := ditDirectory
          else
            ItemType := ditFile;
          FileName := AnsiToUtf8(f.Name);
          ModifiedDate := FileDateToDateTime(f.Time);
          OwnerName := 'anonymous';
          GroupName := 'all';
          OwnerPermissions := 'rwx';
          GroupPermissions := 'rwx';
          UserPermissions := 'rwx';
        end;
      until SysUtils.FindNext(f)<>0;
      SysUtils.FindClose(f);
    end;
  end;
end;

procedure TFtpServerThread.IdFTPServerRenameFile(
  ASender: TIdFTPServerThread; const ARenameFromFile,
  ARenameToFile: String);
begin
  try
    RenameFile(PChar(Utf8ToAnsi(ASender.HomeDir + ARenameFromFile)),
               PChar(Utf8ToAnsi(ASender.HomeDir + ARenameToFile)));
  except
  end;
end;

procedure TFtpServerThread.IdFTPServerRetrieveFile(
  ASender: TIdFTPServerThread; const AFileName: String;
  var VStream: TStream);
var
  FileName: string;
begin
  FileName := Utf8ToAnsi(ASender.HomeDir + AFileName);
  if FileExists(FileName) then
  begin
    try
      VStream := TFileStream.Create(FileName, fmOpenRead);
    except
    end;
  end;
end;

procedure TFtpServerThread.IdFTPServerStoreFile(ASender: TIdFTPServerThread;
  const AFileName: String; AAppend: Boolean; var VStream: TStream);
var
  FileName: string;
begin
  try
    FileName := Utf8ToAnsi(ASender.HomeDir + AFileName);
    if FileExists(FileName) then
      VStream := TFileStream.Create(FileName, fmOpenWrite)
    else
      VStream := TFileStream.Create(FileName, fmCreate);
    if AAppend then
    begin
      VStream.Seek(VStream.Size, soBeginning);
    end;
  except
  end;
end;

procedure TFtpServerThread.IdFTPServerUserLogin(
  ASender: TIdFTPServerThread; const AUsername, APassword: String;
  var AAuthenticated: Boolean);
begin
  AAuthenticated := True;
  ASender.HomeDir := FHomeDir;
end;

end.

